Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/databa_1/tablelst.frm

Visual Basic Form | 1999-07-10 | 18.0 KB | 514 lines

VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form frmTablesTVW
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "List of Tables"
   ClientHeight    =   4380
   ClientLeft      =   2760
   ClientTop       =   3750
   ClientWidth     =   7410
   Icon            =   "TablelsTVW.frx":0000
   LinkTopic       =   "Form1"
   LockControls    =   -1  'True
   MaxButton       =   0   'False
   MDIChild        =   -1  'True
   MinButton       =   0   'False
   ScaleHeight     =   4380
   ScaleWidth      =   7410
   ShowInTaskbar   =   0   'False
   Begin VB.CommandButton cmdFldProperty
      Caption         =   "Fld property"
      Height          =   375
      Left            =   4890
      TabIndex        =   11
      Top             =   3780
      Width           =   1035
   End
   Begin VB.CommandButton cmdTable
      Caption         =   "Table"
      Height          =   375
      Left            =   3720
      TabIndex        =   10
      Top             =   3780
      Width           =   1035
   End
   Begin VB.CommandButton cmdClose
      Caption         =   "Close"
      Height          =   375
      Left            =   6060
      TabIndex        =   0
      Top             =   3780
      Width           =   1035
   End
   Begin MSComctlLib.TreeView tvwDB
      Height          =   3210
      Left            =   180
      TabIndex        =   3
      Top             =   900
      Width           =   3210
      _ExtentX        =   5662
      _ExtentY        =   5662
      _Version        =   393217
      Style           =   7
      ImageList       =   "ImageList1"
      Appearance      =   1
   End
   Begin MSComctlLib.ListView lvwProperties
      Height          =   2130
      Left            =   3690
      TabIndex        =   9
      Top             =   1530
      Width           =   3435
      _ExtentX        =   6059
      _ExtentY        =   3757
      View            =   3
      LabelEdit       =   1
      LabelWrap       =   -1  'True
      HideSelection   =   0   'False
      FullRowSelect   =   -1  'True
      _Version        =   393217
      Icons           =   "ImageList1"
      SmallIcons      =   "ImageList1"
      ForeColor       =   -2147483640
      BackColor       =   -2147483643
      BorderStyle     =   1
      Appearance      =   1
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
         Name            =   "MS Sans Serif"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      NumItems        =   0
   End
   Begin MSComctlLib.ImageList ImageList1
      Left            =   2850
      Top             =   330
      _ExtentX        =   1005
      _ExtentY        =   1005
      BackColor       =   -2147483643
      ImageWidth      =   16
      ImageHeight     =   16
      MaskColor       =   12632256
      _Version        =   393216
      BeginProperty Images {2C247F25-8591-11D1-B16A-00C0F0283628}
         NumListImages   =   5
         BeginProperty ListImage1 {2C247F27-8591-11D1-B16A-00C0F0283628}
            Picture         =   "TablelsTVW.frx":030A
            Key             =   "imgDatabase"
         EndProperty
         BeginProperty ListImage2 {2C247F27-8591-11D1-B16A-00C0F0283628}
            Picture         =   "TablelsTVW.frx":0556
            Key             =   "imgClosed"
         EndProperty
         BeginProperty ListImage3 {2C247F27-8591-11D1-B16A-00C0F0283628}
            Picture         =   "TablelsTVW.frx":0652
            Key             =   "imgOpen"
         EndProperty
         BeginProperty ListImage4 {2C247F27-8591-11D1-B16A-00C0F0283628}
            Picture         =   "TablelsTVW.frx":0766
            Key             =   "imgField"
         EndProperty
         BeginProperty ListImage5 {2C247F27-8591-11D1-B16A-00C0F0283628}
            Picture         =   "TablelsTVW.frx":0878
            Key             =   "imgProp"
         EndProperty
      EndProperty
   End
   Begin VB.Label lblFieldName
      BorderStyle     =   1  'Fixed Single
      Height          =   285
      Left            =   4905
      TabIndex        =   8
      Top             =   1170
      Width           =   2130
   End
   Begin VB.Label lblField
      Caption         =   "Field:"
      Height          =   195
      Left            =   4320
      TabIndex        =   7
      Top             =   1215
      Width           =   510
   End
   Begin VB.Label lblTable
      Caption         =   "Table:"
      Height          =   195
      Left            =   4320
      TabIndex        =   6
      Top             =   900
      Width           =   510
   End
   Begin VB.Label lblTableName
      BorderStyle     =   1  'Fixed Single
      Height          =   285
      Left            =   4905
      TabIndex        =   5
      Top             =   855
      Width           =   2130
   End
   Begin VB.Label lblFieldProperties
      Caption         =   "Field properties:"
      Height          =   195
      Left            =   3780
      TabIndex        =   4
      Top             =   585
      Width           =   1140
   End
   Begin VB.Label lblTableList
      Caption         =   "Tables && Fields:"
      Height          =   195
      Left            =   180
      TabIndex        =   2
      Top             =   585
      Width           =   2310
   End
   Begin VB.Label lblDatabase
      Caption         =   "Database:"
      Height          =   420
      Left            =   180
      TabIndex        =   1
      Top             =   45
      Width           =   6315
   End
Attribute VB_Name = "frmTablesTVW"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
' TablesTVW.frm
' By Herman Liu
Option Explicit
Dim rsSchema As adodb.Recordset
Dim rs As adodb.Recordset
Dim mNodeDB As node
Dim mNodeTables As node
Dim mnodeFields As node
Dim mListItem As ListItem
Dim mCurrListRef           ' Flag to assure this node is already clicked
Private Sub Form_Load()
    On Error Resume Next
    lblDatabase = "Database: " + gFileSpec
     ' Configure ListView control.
    lvwProperties.ListItems.Clear
    lvwProperties.Icons = ImageList1
    lvwProperties.SmallIcons = ImageList1
    lvwProperties.ColumnHeaders.Clear
    lvwProperties.ColumnHeaders.Add , , "Property", 1700
    lvwProperties.ColumnHeaders.Add , , "Value", lvwProperties.Width - 1700
    lvwProperties.View = lvwReport
        ' we want to show coloumn headers
    lvwProperties.HideColumnHeaders = False
        ' We don't want shade/highlight any item at start
    lvwProperties.HideSelection = True

       'Configure TreeView
    tvwDB.Nodes.Clear
    Set gAcnn = New adodb.Connection
    gAcnn.CursorLocation = adUseClient
    gAcnn.Open "PROVIDER=Microsoft.Jet.OLEDB.3.51;Data Source=" & gFileSpec & ";"
       ' If you use 4.0
    ' gAcnn.Open "PROVIDER=Microsoft.Jet.OLEDB.4.0;Data Source=" & gFileSpec & ";"
    Set rsSchema = gAcnn.OpenSchema(adSchemaTables, Array(Empty, Empty, Empty, "TABLE"))
    Me.MousePointer = vbHourglass
    '--------------------------------------------------------------------
    ' Set root node of TreeView.
    '--------------------------------------------------------------------
    Set mNodeDB = tvwDB.Nodes.Add(, , "RootDB", "Database", "imgDatabase")
    mNodeDB.Tag = "RootDB"

    '------------------------
    ' Set table nodes.
    '------------------------
    Dim mtblName As String
    Do Until rsSchema.EOF
         ' Since MS current schema returns tables named "MSys...."
         ' as well as their TABLE_TYPE is also "TABLE", we exclude them.
        If UCase(Left(rsSchema!Table_name, 4)) <> "MSYS" Then
           If UCase(Left(rsSchema!Table_name, 11)) <> "SWITCHBOARD" Then
               mtblName = rsSchema!Table_name
               Set mNodeTables = tvwDB.Nodes.Add("RootDB", tvwChild, "X" & mtblName, mtblName, "imgClosed")

               mNodeTables.Tag = "Tables"
           End If
        End If
        rsSchema.MoveNext
    Loop
    rsSchema.Close
    If mNodeTables Is Nothing Then
        Me.MousePointer = vbDefault
        MsgBox "No table in the database"
        Exit Sub
    End If
    ' REDIM gstrFields and gstrFieldsOrig according to No. of tables in DB
    Dim mNumTables As Integer
    mNumTables = tvwDB.Nodes("RootDB").Children
    ReDim gstrFields(mNumTables, 2) As String
    ReDim gstrFieldsOrig(mNumTables, 2) As String
    '----------------------------------------------------------------------
    ' Set field nodes for each table (at the same time fill first dimension
    '   of gstrFields and gstrFieldsOrig)
    ' We only want field Name, Type, DefinedSize, Attributes & NumericScale
    ' totalling 6.
    '----------------------------------------------------------------------
    Dim i As Integer, n As Integer, j As Integer
    Dim mctn As Integer
    Dim mType As Long
    Dim mAttr As Integer
    Dim mstrType As String
    Dim mstrAttr As String
    Dim mFldName As String
    Set rs = New adodb.Recordset
    mctn = tvwDB.Nodes("RootDB").Children
      ' We begin with the first table, but what is its node index in Nodex?
    n = tvwDB.Nodes("RootDB").Child.FirstSibling.Index
      ' The Nodes collection is a 1-based collection.
    For i = n To mctn + n
       mtblName = tvwDB.Nodes(i).Text

         ' We have the table name, so we Query that table in order to get
         ' the field names.  1 record is more than good enough, hence the
         ' second argument is 1.
           Set rs = gAcnn.Execute("SELECT * FROM [" & mtblName & "]", 1, 1)

       For j = 0 To rs.Fields.Count - 1
            mFldName = rs.Fields(j).Name
            Set mnodeFields = tvwDB.Nodes.Add("X" & mtblName, tvwChild, "X" & mFldName, mFldName, "imgField")
            mnodeFields.Tag = "Fields"
       Next
       rs.Close

       ' Fill first dimension of gstrFields and gstrFieldsOrig with table name
       ' (starting with subscript 0)
       gstrFields(i - n, 1) = mtblName
       gstrFieldsOrig(i - n, 1) = mtblName
    Next i
     ' Sort the top group of nodes.
    tvwDB.Nodes(1).Sorted = True
     ' Expand top node.
    tvwDB.Nodes(1).Expanded = True
    Me.MousePointer = vbDefault
    Exit Sub
End Sub
' Called from tvwDB_Dblclick
Private Sub GetProperties(mtblName, mFldName, mNodeKey)
    ' Query that retrieves the fields
    Set rs = gAcnn.Execute("SELECT * FROM [" & mtblName & "]", 1, 1)
    lvwProperties.ListItems.Clear
    Dim i As Integer
    Dim mthisFldName As String
    Dim mType As Long
    Dim mAttr
    Dim mstrType As String
    Dim mstrAttr As String
    Dim mDefinedSize
    Dim mNumericScale
    Dim mPrecision
    For i = 0 To rs.Fields.Count - 1
        If CStr(rs.Fields(i).Name) = mFldName Then
             mthisFldName = rs.Fields(i).Name
                mType = rs.Fields(i).Type
             mstrType = ConvType(mType)
                mAttr = rs.Fields(i).Attributes
             mstrAttr = ConvAttr(mAttr)
             mDefinedSize = rs.Fields(i).DefinedSize
             mNumericScale = rs.Fields(i).NumericScale
             mPrecision = rs.Fields(i).Precision

             Set mListItem = lvwProperties.ListItems.Add(, , _
                  Text:="Name:", SmallIcon:="imgProp")
             mListItem.SubItems(1) = mthisFldName

             Set mListItem = lvwProperties.ListItems.Add(, , _
                  Text:="Type:", SmallIcon:="imgProp")
             mListItem.SubItems(1) = mstrType

             Set mListItem = lvwProperties.ListItems.Add(, , _
                  Text:="Attributes:", SmallIcon:="imgProp")
             mListItem.SubItems(1) = mstrAttr

             Set mListItem = lvwProperties.ListItems.Add(, , _
                  Text:="DefinedSize:", SmallIcon:="imgProp")
             mListItem.SubItems(1) = mDefinedSize

             Set mListItem = lvwProperties.ListItems.Add(, , _
                  Text:="NumericScale:", SmallIcon:="imgProp")
             mListItem.SubItems(1) = mNumericScale

             Set mListItem = lvwProperties.ListItems.Add(, , _
                  Text:="Precision:", SmallIcon:="imgProp")
             mListItem.SubItems(1) = mPrecision
             Exit For
        End If
    Next i
    lblTableName.Caption = Space(4) & mtblName
    lblFieldName.Caption = Space(4) & mFldName
    rs.Close
    Set rs = Nothing
    mCurrListRef = mNodeKey
End Sub
Private Sub tvwDB_Expand(ByVal node As node)
    If node.Tag = "Tables" Then
        node.Image = "imgOpen"
    End If
End Sub
Private Sub tvwDB_Collapse(ByVal node As node)
    If node.Tag = "Tables" Then
        node.Image = "imgClosed"
    End If
End Sub
Private Sub tvwDB_DblClick()
   Dim tmpNode As node
   Dim tmpText As String
   Dim tmpKey
   Dim tmpTag
   Dim tmpParentText As String
   Dim tmplistitem As ListItem
       ' Set the variable to the SelectedItem
   Set tmpNode = tvwDB.SelectedItem
       ' Retrieve properties of the node
   tmpText = tmpNode.Text
   tmpKey = tmpNode.Key
   tmpTag = tmpNode.Tag
   If tmpTag = "RootDB" Then
        Exit Sub
   End If
   If tmpTag = "Tables" Then
        ' Invoke the frmDBGrid form, then EXIT
        If ExistFormCap(tmpText) = False Then
              ' Supply table name as frmGrid's caption
              ' Each copy object of frmDBGrid has to use
              ' a different name.  We use that of table name.
              ' Create a variant, assign table name as its
              ' name before assigning frmDBGrid to it.
            Dim tmpObject
            tmpObject = tmpText
            Set tmpObject = New frmDBGrid
               ' frmDBGrid needs the value of gTableName
            gTableName = tmpText

            tmpObject.Show
               ' Form caption being the table name (so that later
               ' we are able to check if the form caption bearing
               ' the table name already exists)
            tmpObject.Caption = tmpText
        Else
            MsgBox "Table is already opened"
        End If
        Exit Sub
   End If
   If tmpTag = "Fields" Then
        tmpParentText = tmpNode.Parent.Text
        If mCurrListRef <> tmpKey Then
             GetProperties tmpParentText, tmpText, tmpKey
        End If

        tmpNode.Sorted = True

         ' Enusre field name property is readily visible
        Set tmplistitem = lvwProperties.FindItem(tmpText, , , lvwPartial)
        If Not (tmplistitem Is Nothing) Then
             tmplistitem.EnsureVisible
        End If
   End If
End Sub
Private Sub cmdTable_Click()
   If tvwDB.SelectedItem Is Nothing Then
       MsgBox "Please select a table first"
       Exit Sub
   End If

   Dim tmpNode As node
   Dim tmpText As String
   Dim tmpKey
   Dim tmpTag
   Dim tmpParentText As String
   Dim tmplistitem As ListItem
       ' Set the variable to the SelectedItem
   Set tmpNode = tvwDB.SelectedItem
       ' Retrieve properties of the node
   tmpText = tmpNode.Text
   tmpKey = tmpNode.Key
   tmpTag = tmpNode.Tag
   If tmpTag = "RootDB" Or tmpTag = "Fields" Then
       MsgBox "Please select a table first"
       Exit Sub
   End If
   If tmpTag = "Tables" Then
        ' Invoke the frmDBGrid form, then EXIT
        If ExistFormCap(tmpText) = False Then
               ' Supply table name as frmGrid's caption
            Dim tmpObject
            tmpObject = tmpText
            Set tmpObject = New frmDBGrid
               ' frmDBGrid needs the value of gTableName
            gTableName = tmpText

            tmpObject.Show
               ' Form caption being the table name (so that later
               ' we are able to check if the form caption bearing
               ' the table name already exists)
            tmpObject.Caption = tmpText
        Else
            MsgBox "Table is already opened"
        End If
        Exit Sub
   End If
End Sub
Private Sub cmdFldProperty_Click()
   If tvwDB.SelectedItem Is Nothing Then
       MsgBox "Please select a field of a table first"
       Exit Sub
   End If
   Dim tmpNode As node
   Dim tmpText As String
   Dim tmpKey
   Dim tmpTag
   Dim tmpParentText As String
   Dim tmplistitem As ListItem
       ' Set the variable to the SelectedItem
   Set tmpNode = tvwDB.SelectedItem
       ' Retrieve properties of the node
   tmpText = tmpNode.Text
   tmpKey = tmpNode.Key
   tmpTag = tmpNode.Tag
   If tmpTag = "RootDB" Or tmpTag = "Tables" Then
       MsgBox "Please select a field of a table first"
       Exit Sub
   End If
   If tmpTag = "Fields" Then
        tmpParentText = tmpNode.Parent.Text
        If mCurrListRef <> tmpKey Then
             GetProperties tmpParentText, tmpText, tmpKey
        End If

        tmpNode.Sorted = True

         ' Enusre field name property is readily visible
        Set tmplistitem = lvwProperties.FindItem(tmpText, , , lvwPartial)
        If Not (tmplistitem Is Nothing) Then
             tmplistitem.EnsureVisible
        End If
   End If
End Sub
Function ExistFormCap(FormCap As String) As Boolean
    Dim mExistFormCap As Boolean
    mExistFormCap = False
    Dim i As Integer
    For i = Forms.Count - 1 To 0 Step -1
        If UCase(Forms(i).Caption) = UCase(FormCap) Then
             mExistFormCap = True
             Exit For
        End If
    Next
    ExistFormCap = mExistFormCap
End Function
Private Sub cmdClose_Click()
   On Error Resume Next
   gAcnn.Close
   Unload Me
End Sub